﻿module BoardTool.Commands

open System
open System.Collections.Generic

open BoardTool.Tool
open BoardTool.DirTree

let private (|InDict|_|) (dict : Dictionary<'K, 'V>) key =
    let pp, value = dict.TryGetValue( key )
    if pp then Some value else None


[<AbstractClass>]
type BaseCommandFactory( name : string, descr : string ) =
    let positionals = ResizeArray<string * string>()
    let tagged = ResizeArray<string * string>()

    let posHandlers = Dictionary<string, string -> unit>()
    let flagHandlers = Dictionary<string, unit -> unit>()
    let namedHandlers = Dictionary<string, string -> unit>()
    
    member this.addPositional( name, descr, handler ) =
        positionals.Add( (name, descr) )
        posHandlers.[name] <- handler

    member this.addFlag( name, descr, handler ) =
        tagged.Add( (name, descr) )
        flagHandlers.[name] <- handler

    member this.addNamed( name, syntax, descr, handler ) =
        tagged.Add( (name + " " + syntax, descr) )
        namedHandlers.[name] <- handler

    member this.Syntax = 
        name + " " + (positionals |> Seq.map fst |> String.concat " ")

    abstract reset : unit -> unit
    abstract createCommand : unit -> ICommand

    interface ICommandFactory with
        member this.name = name
        
        member this.appendBriefHelp( hf ) =
            hf.appendCommandHelp( this.Syntax, descr )
        
        member this.appendDetailedHelp( hf) =
            hf.appendCommandHelp( this.Syntax, descr )
            for (posName, posHelp) in positionals do
                hf.appendArgumentHelp( posName, posHelp )
            for (tagSyntax, tagHelp) in tagged do
                hf.appendArgumentHelp( tagSyntax, tagHelp )

        member this.parse( args : string list ) =
            this.reset()

            let rec parseRec args ubp =
                match args, ubp with
                | (InDict flagHandlers handler) :: args', _ ->
                    handler()
                    parseRec args' ubp 
                | (InDict namedHandlers handler) :: args', _ ->
                    match args' with
                    | arg1 :: args'' ->
                        handler arg1
                        parseRec args'' ubp 
                    | [] ->
                        failwithf "%s requires argument" (List.head args)
                | tag :: args', _ when tag.StartsWith( "-" ) ->
                    failwithf "Unknown tag: %s" tag
                | arg :: args', ubp :: ubp' ->
                    posHandlers.[ubp] arg
                    parseRec args' ubp' 
                | [], ubp :: _ ->
                    failwithf "Unbound positional argument: %s" ubp
                | _, [] ->
                    args

            let ubp = positionals |> Seq.map fst |> List.ofSeq
            let args' = parseRec args ubp
            
            this.createCommand(), args'




[<AttributeUsage(AttributeTargets.Class)>]
type CommandOptionsAttribute( positionals : string[], publishedTags : string[] ) =
    inherit Attribute()
    member this.Positionals = positionals
    member this.PublishedTags = publishedTags

[<AttributeUsage(AttributeTargets.Method ||| AttributeTargets.Property ||| AttributeTargets.Field)>]
type PositionalOptionAttribute( syntax : string, helpText : string ) =
    inherit Attribute()
    member this.Syntax = syntax
    member this.HelpText = helpText

[<AttributeUsage(AttributeTargets.Method ||| AttributeTargets.Property ||| AttributeTargets.Field)>]
type FlagOptionAttribute( tag : string, helpText : string ) =
    inherit Attribute()
    member this.Tag = tag
    member this.HelpText = helpText

[<AttributeUsage(AttributeTargets.Method ||| AttributeTargets.Property ||| AttributeTargets.Field)>]
type NamedOptionAttribute( tag : string, syntax : string, helpText : string ) =
    inherit Attribute()
    member this.Tag = tag
    member this.Syntax = syntax
    member this.HelpText = helpText

[<CommandOptions( [| "DIR" |], [| |] )>]
type private DirOptionsTest =
    {
    [<PositionalOption("DIR", "working directory")>]
    mutable Dir : string
    }

let private grabAttrFromMember<'ATTR when 'ATTR :> Attribute> (aMember : Reflection.MemberInfo) =
    let posOptAttr = Attribute.GetCustomAttribute( aMember, typeof<'ATTR> )
    if posOptAttr = null then None
    else Some (posOptAttr :?> 'ATTR)

let private (|IsPositionalOption|_|) (aMember : Reflection.MemberInfo) =
    grabAttrFromMember<PositionalOptionAttribute> aMember

let private (|IsFlagOption|_|) (aMember : Reflection.MemberInfo) =
    grabAttrFromMember<FlagOptionAttribute> aMember

let private (|IsNamedOption|_|) (aMember : Reflection.MemberInfo) =
    grabAttrFromMember<NamedOptionAttribute> aMember

let private EMPTY_ARGS : obj[] = Array.create 0 null
let private makeSingleton (x : obj) = Array.create 1 x

let private mkMtdFlagHandler (mtd : Reflection.MethodInfo) =
    let mtdArgs = mtd.GetParameters()
    if mtdArgs.Length <> 0 then
        failwithf "Method %s::%s should have 0 arguments, but has %d"
            mtd.DeclaringType.Name mtd.Name mtdArgs.Length
    (fun args -> mtd.Invoke( args, EMPTY_ARGS ) |> ignore)

let private mkMtdValHandler (mtd : Reflection.MethodInfo) =
    let mtdArgs = mtd.GetParameters()
    if mtdArgs.Length <> 1 then
        failwithf "Method %s::%s should have 0 arguments, but has %d"
            mtd.DeclaringType.Name mtd.Name mtdArgs.Length
    let valType = mtdArgs.[0].ParameterType
    (fun args str -> 
        let x = LexCast.objFromString valType str
        mtd.Invoke( args, makeSingleton x ) |> ignore
    )

let private mkPropFlagHandler (prop : Reflection.PropertyInfo) =
    let propType = prop.PropertyType
    if propType <> typeof<bool> then
        failwithf "Property %s::%s should have type bool, but has type %s"
            prop.DeclaringType.Name prop.Name propType.Name
    let propIndexParms = prop.GetIndexParameters()
    if propIndexParms.Length <> 0 then
        failwithf "Property %s::%s should have 0 index parameters, but has %d"
            prop.DeclaringType.Name prop.Name propIndexParms.Length
    (fun args -> prop.SetValue( args, true :> obj, EMPTY_ARGS ) )

let private mkPropValHandler (prop : Reflection.PropertyInfo) =
    let propIndexParms = prop.GetIndexParameters()
    if propIndexParms.Length <> 0 then
        failwithf "Property %s::%s should have 0 index parameters, but has %d"
            prop.DeclaringType.Name prop.Name propIndexParms.Length
    let propType = prop.PropertyType
    (fun args str ->
        let x = LexCast.objFromString propType str
        prop.SetValue( args, x, EMPTY_ARGS )
    )

let private mkFieldFlagHandler (fld : Reflection.FieldInfo) =
    let fldType = fld.FieldType
    if fldType <> typeof<bool> then
        failwithf "Field %s::%s should have type bool, but has type %s"
            fld.DeclaringType.Name fld.Name fldType.Name
    (fun args -> fld.SetValue( args, true :> obj ))

let private mkFieldValHandler (fld : Reflection.FieldInfo) =
    let fldType = fld.FieldType
    (fun args str -> 
        let x = LexCast.objFromString fldType str
        fld.SetValue( args, x )
    )

let private grabArgsFromAnnotations' (tt : Type) (commandOptions : CommandOptionsAttribute) =
    let grabbedPosHelp = Dictionary<string, string>()
    let grabbedPosHandlers = Dictionary<string, 'T -> string -> unit>()

    let grabbedFlagHelp = Dictionary<string, string>()
    let grabbedFlagHandlers = Dictionary<string, 'T -> unit>()

    let grabbedNamedHelp = Dictionary<string, string * string>()
    let grabbedNamedHandlers = Dictionary<string, 'T -> string -> unit>()

    let addPos name help handler =
        grabbedPosHelp.[name] <- help
        grabbedPosHandlers.[name] <- handler

    let addFlag tag help handler =
        grabbedFlagHelp.[tag] <- help
        grabbedFlagHandlers.[tag] <- handler

    let addNamed tag syntax help handler =
        grabbedNamedHelp.[tag] <- (syntax, help)
        grabbedNamedHandlers.[tag] <- handler

    let parseMemberInfo mkFlagHandler mkValHandler mi =
        match mi with
        | IsPositionalOption posAttr ->
            let han = mkValHandler mi
            addPos posAttr.Syntax posAttr.HelpText han
        | IsFlagOption flagAttr ->
            let han = mkFlagHandler mi
            addFlag flagAttr.Tag flagAttr.HelpText han
        | IsNamedOption namedAttr ->
            let han = mkValHandler mi
            addNamed namedAttr.Tag namedAttr.Syntax namedAttr.HelpText han
        | _ -> 
            ()
                
    for mtd in tt.GetMethods( ) do
        parseMemberInfo mkMtdFlagHandler mkMtdValHandler mtd
            
    for prop in tt.GetProperties( ) do
        parseMemberInfo mkPropFlagHandler mkPropValHandler prop

    for fld in tt.GetFields( ) do
        parseMemberInfo mkFieldFlagHandler mkFieldValHandler fld

    // TODO parse base class?

    (
    commandOptions, 
    grabbedPosHelp, grabbedPosHandlers, 
    grabbedFlagHelp, grabbedFlagHandlers, 
    grabbedNamedHelp, grabbedNamedHandlers
    )

let private grabArgsFromAnnotations (tt : Type) =
    let commandOptions = Attribute.GetCustomAttribute( tt, typeof<CommandOptionsAttribute> )
    if commandOptions = null then
        None
    else
        let commandOptions = commandOptions :?> CommandOptionsAttribute
        Some <| grabArgsFromAnnotations' tt commandOptions
        

[<AbstractClass>]
type ReflectionCommandFactory<'T>( name : string, descr : string ) as this =
    let positionals = ResizeArray<string * string>()
    let tagged = ResizeArray<string * string>()

    let posHandlers = Dictionary<string, 'T -> string -> unit>()
    let flagHandlers = Dictionary<string, 'T -> unit>()
    let namedHandlers = Dictionary<string, 'T -> string -> unit>()

    do
        match grabArgsFromAnnotations typeof<'T> with
        | None -> ()
        | Some( cmdOptions, gPosHelp, gPosHandlers, gFlagHelp, gFlagHandlers, gNamedHelp, gNamedHandlers ) ->
            for pos in cmdOptions.Positionals do
                this.addPositional( pos, gPosHelp.[pos], gPosHandlers.[pos] )
            
            for tag in cmdOptions.PublishedTags do
                if gFlagHandlers.ContainsKey( tag ) then
                    this.addFlag( tag, gFlagHelp.[tag], gFlagHandlers.[tag] )
                elif gNamedHandlers.ContainsKey( tag ) then
                    let syntax, help = gNamedHelp.[tag]
                    this.addNamed( tag, syntax, help, gNamedHandlers.[tag] )
                else
                    failwithf "Tag not found: %s" tag
    
    member this.addPositional( name, descr, handler ) =
        positionals.Add( (name, descr) )
        posHandlers.[name] <- handler

    member this.addFlag( name, descr, handler ) =
        tagged.Add( (name, descr) )
        flagHandlers.[name] <- handler

    member this.addNamed( name, syntax, descr, handler ) =
        tagged.Add( (name + " " + syntax, descr) )
        namedHandlers.[name] <- handler

    abstract member initArgs : unit -> 'T
    abstract member createCommand : 'T -> ICommand

    member this.Syntax = 
        name + " " + (positionals |> Seq.map fst |> String.concat " ")

    interface ICommandFactory with
        member this.name = name
        
        member this.appendBriefHelp( hf ) =
            hf.appendCommandHelp( this.Syntax, descr )
        
        member this.appendDetailedHelp( hf) =
            hf.appendCommandHelp( this.Syntax, descr )
            for (posName, posHelp) in positionals do
                hf.appendArgumentHelp( posName, posHelp )
            for (tagSyntax, tagHelp) in tagged do
                hf.appendArgumentHelp( tagSyntax, tagHelp )

        member this.parse( args : string list ) =
            let state = this.initArgs()

            let rec parseRec args ubp =
                match args, ubp with
                | (InDict flagHandlers handler) :: args', _ ->
                    handler state
                    parseRec args' ubp 
                | (InDict namedHandlers handler) :: args', _ ->
                    match args' with
                    | arg1 :: args'' ->
                        handler state arg1
                        parseRec args'' ubp 
                    | [] ->
                        failwithf "%s requires argument" (List.head args)
                | tag :: args', _ when tag.StartsWith( "-" ) ->
                    failwithf "Unknown tag: %s" tag
                | arg :: args', ubp :: ubp' ->
                    posHandlers.[ubp] state arg
                    parseRec args' ubp' 
                | [], ubp :: _ ->
                    failwithf "Unbound positional argument: %s" ubp
                | _, [] ->
                    args

            let ubp = positionals |> Seq.map fst |> List.ofSeq
            let args' = parseRec args ubp
            
            this.createCommand( state ), args'


[<AbstractClass>]
type MapDirCommand<'T>( dir : string ) =
    abstract processFile : string -> 'T
    abstract reduce : IDictionary<string, 'T> -> unit
    abstract Id : string

    interface ICommand with
        member this.id = this.Id
        
        member this.run() =
            let logger = consoleLogger()
            eprintfn ">>> dir: %s" dir
            mapBoards this.processFile logger dir
            |> this.reduce 

[<AbstractClass>]
type TransformDirCommand<'T>( srcDir, destDir ) =
    abstract transformFile : string -> string -> 'T
    abstract reduce : IDictionary<string, 'T> -> unit
    abstract Id : string

    interface ICommand with
        member this.id = this.Id

        member this.run() =
            let logger = consoleLogger()
            transformBoards this.transformFile logger srcDir destDir
            |> this.reduce 

[<AbstractClass>]
type MapDirCommandFactory( name, descr ) as this =
    inherit BaseCommandFactory( name, descr )
    let dir = ref ""
    do this.addPositional( "DIR", "working directory", ((:=) dir ) )
    
    override this.reset() =
        dir := ""

    abstract createCommand : string -> ICommand

    override this.createCommand() =
        this.createCommand( !dir )

[<AbstractClass>]
type TransformDirCommandFactory( name, descr ) as this =
    inherit BaseCommandFactory( name, descr )
    let srcDir = ref ""
    let destDir = ref ""
    do this.addPositional( "SRCDIR", "source directory", ((:=) srcDir) )
    do this.addPositional( "DESTDIR", "destination directory", ((:=) destDir) )

    override this.reset() =
        srcDir := ""
        destDir := ""

    abstract createCommand : string * string -> ICommand

    override this.createCommand() =
        this.createCommand( !srcDir, !destDir )
